home *** CD-ROM | disk | FTP | other *** search
/ Gold Medal Software 1 / Gold Medal Software Volume 1 (Gold Medal) (1994).iso / prog / tpwprog6.arj / DRAWBITS.PAS < prev    next >
Encoding:
Pascal/Delphi Source File  |  1992-07-02  |  3.1 KB  |  133 lines
  1. { drawbits.pas -- Draw and use bitmaps at runtime }
  2.  
  3. program DrawBits;
  4.  
  5. uses WinTypes, WinProcs, WObjects;
  6.  
  7. const
  8.  
  9.   bmHeight = 256;   { Height of bitmap }
  10.   bmWidth  = 256;   { Width of bitmap }
  11.  
  12. type
  13.  
  14.   DrawBitsApplication = object(TApplication)
  15.     procedure InitMainWindow; virtual;
  16.   end;
  17.  
  18.   PDrawBitsWindow = ^DrawBitsWindow;
  19.   DrawBitsWindow = object(TWindow)
  20.     TheBitmap: HBitmap;
  21.     constructor Init(AParent: PWindowsObject; ATitle: PChar);
  22.     destructor Done;
  23.       virtual;
  24.     procedure SetupWindow;
  25.       virtual;
  26.     procedure Paint(PaintDC: HDC; var PaintInfo: TPaintStruct);
  27.       virtual;
  28.   end;
  29.  
  30. {- Create and draw into a bitmap }
  31. function MakeBitmap(HWindow: HWnd): HBitmap;
  32. var
  33.   Dc, MemDC: HDC;
  34.   OldBitmap, HBits: HBitmap;
  35.   X1, Y1, X2, Y2: Integer;
  36. begin
  37. {- Create bitmap and fill it with white }
  38.   Dc := GetDC(HWindow);
  39.   MemDC := CreateCompatibleDC(Dc);
  40.   HBits := CreateCompatibleBitmap(Dc, bmWidth, bmHeight);
  41.   OldBitmap := SelectObject(MemDC, HBits);
  42.   PatBlt(MemDC, 0, 0, bmWidth, bmHeight, whiteness);
  43.  
  44. {- Draw outline }
  45.   Rectangle(MemDC, 0, 0, bmWidth, bmHeight);
  46.  
  47. {- Draw concentric circles }
  48.   X1 := 0; Y1 := 0; X2 := bmWidth; Y2 := bmHeight;
  49.   while (X2 >= X1) and (Y2 >= Y1) do
  50.   begin
  51.     Ellipse(MemDC, X1, Y1, X2, Y2);
  52.     X1 := X1 + 10;
  53.     X2 := X2 - 10;
  54.     Y1 := Y1 + 10;
  55.     Y2 := Y2 - 10
  56.   end;
  57.  
  58. {- Draw X through bitmap's center }
  59.   MoveTo(MemDC, 0, 0);
  60.   LineTo(MemDC, bmWidth, bmHeight);
  61.   MoveTo(MemDC, 0, bmHeight);
  62.   LineTo(MemDC, bmWidth, 0);
  63.  
  64. {- Dispose of supporting objects and return bitmap handle }
  65.   SelectObject(MemDC, OldBitmap);
  66.   DeleteDC(MemDC);
  67.   ReleaseDC(HWindow, Dc);
  68.   MakeBitmap := HBits
  69. end;
  70.  
  71. { DrawBitsApplication }
  72.  
  73. {- Initialize DrawBitsApplication object's window }
  74. procedure DrawBitsApplication.InitMainWindow;
  75. begin
  76.   MainWindow := New(PDrawBitsWindow, Init(nil, 'DrawBits'))
  77. end;
  78.  
  79.  
  80. { DrawBitsWindow }
  81.  
  82. {- Construct DrawBitsWindow object }
  83. constructor DrawBitsWindow.Init(AParent: PWindowsObject;
  84.   ATitle: PChar);
  85. begin
  86.   TWindow.Init(AParent, ATitle)
  87. end;
  88.  
  89. {- Destroy the DrawBitsWindow object }
  90. destructor DrawBitsWindow.Done;
  91. begin
  92.   if TheBitmap <> 0 then
  93.     DeleteObject(TheBitmap);
  94.   TWindow.Done
  95. end;
  96.  
  97. {- Create the bitmap and store its handle }
  98. procedure DrawBitsWindow.SetupWindow;
  99. begin
  100.   TWindow.SetupWindow;
  101.   TheBitmap := MakeBitmap(HWindow)
  102. end;
  103.  
  104. {- Display the bitmap }
  105. procedure DrawBitsWindow.Paint(PaintDC: HDC;
  106.   var PaintInfo: TPaintStruct);
  107. var
  108.   MemDC: HDC;
  109.   OldBitmap: HBitmap;
  110. begin
  111.   MemDC := CreateCompatibleDC(PaintDC);
  112.   OldBitmap := SelectObject(MemDC, TheBitmap);
  113.   BitBlt(PaintDC, 0, 0, bmWidth, bmHeight, MemDC, 0, 0, srcCopy);
  114.   SelectObject(MemDC, OldBitmap);
  115.   DeleteDC(MemDC)
  116. end;
  117.  
  118. var
  119.  
  120.   DrawBitsApp: DrawBitsApplication;
  121.  
  122. begin
  123.   DrawBitsApp.Init('DrawBitsApp');
  124.   DrawBitsApp.Run;
  125.   DrawBitsApp.Done
  126. end.
  127.  
  128.  
  129. {--------------------------------------------------------------
  130.   Copyright (c) 1991 by Tom Swan. All rights reserved.
  131.   Revision 1.00    Date: 2/15/1991
  132. ---------------------------------------------------------------}
  133.